unit Locales;

interface

uses
 Forms,
 Classes;

type
 TObjProc = procedure of object;

var
 LocalesList: TStrings = nil;

{ TStrings helper
  Returns index of specified value.
  If Value does not exists, returns -1.
  If List is not assigned, returns -2.
}
function IndexOfValue(const Value: String; List: TStrings): Integer;
//
procedure LocalesListCreate(Path: String; Domain: String = '');
procedure LocalesListFree;
procedure BuildLocalesList(const ParentFolder: String; List: TStrings; Domain: String = '');
procedure GetLangNamesList(ALocalesList, ALangNamesList: TStrings);
//
procedure UseLang(Language: String);
//
procedure TranslateForm(Form: TForm; Language: String; TranslateToo: TObjProc = nil; Domain: String = ''; RestoreLanguage: Boolean = true; RestoreDomain: Boolean = true);

implementation

uses
 SysUtils,
 gnugettext,
 languagecodes;

const
 LocaleFolder = 'locale\';
 MsgFolder = 'LC_MESSAGES\';

 {Common stuff}

function IndexOfValue(const Value: String; List: TStrings): Integer;
 var
  i: Integer;
begin
 if Assigned(List) then
  begin
   i:=List.Count-1;
   repeat
    Result:=i;
    Dec(i);
   until (Result<0) or (List.ValueFromIndex[Result]=Value);
  end
 else
   Result:=-2;
end;

procedure BuildLocalesList(const ParentFolder: String; List: TStrings; Domain: String = '');
 var
  sr: TSearchRec;
  i: Integer;
  Path, s: String;
  Found: Boolean;
begin
 if Assigned(List) then
  begin
   List.Clear;
   //first is always built-in English
   List.Add('en=English (built in)');
   //scan locale folder for subfolders
   Path:=IncludeTrailingPathDelimiter(ParentFolder)+LocaleFolder;
   if DirectoryExists(Path) then
    begin
     i:=FindFirst(Path+'*.*', faDirectory, sr);
     while i=0 do
      begin
       s:=getlanguagename(sr.Name);
       //if subfolder name has language name
       if s<>'' then
        begin
         if Domain='' then //default domain
           Found:=FileExists(Path+sr.Name+'\'+MsgFolder+'default.mo')
         else //exact doamin
           Found:=FileExists(Path+sr.Name+'\'+MsgFolder+Domain+'.mo');
         if Found then
           List.Add(sr.Name+'='+s);
        end;
       i:=FindNext(sr);
      end;
     FindClose(sr);
    end;
  end;
end;

procedure GetLangNamesList(ALocalesList, ALangNamesList: TStrings);
 var
  i: Integer;
begin
 if Assigned(ALocalesList) then
  begin
   if Assigned(ALangNamesList) then
    begin
     ALangNamesList.Clear;
     for i:=0 to ALocalesList.Count-1 do
       ALangNamesList.Add(ALocalesList.ValueFromIndex[i]);
    end;
  end
 else
  begin
   if Assigned(ALangNamesList) then
     ALangNamesList.Clear;
  end;
end;

procedure LocalesListFree;
begin
 if Assigned(LocalesList) then
   FreeAndNil(LocalesList);
end;

procedure LocalesListCreate(Path: String; Domain: String = '');
begin
 LocalesListFree;
 LocalesList:=TStringList.Create;
 BuildLocalesList(Path, LocalesList, Domain);
end;

 {GNU gettext specific procedure}
procedure UseLang(Language: String);
begin
 if getlanguagename(Language)='' then //DM language
  begin
   if Language='russian' then
     UseLanguage('ru')
   else
     if Language='ukrainian' then
       UseLanguage('uk')
     else
       if Language='belarusian' then
         UseLanguage('be')
       else
         if Language='translit' then
           UseLanguage('vo') //translit known as Volapuk
         else
           UseLanguage('en');
  end
 else //code of language
   UseLanguage(Language);
end;

procedure TranslateForm(Form: TForm; Language: String; TranslateToo: TObjProc = nil; Domain: String = ''; RestoreLanguage: Boolean = true; RestoreDomain: Boolean = true);
 var
  CurrLang, CurrDomain: String;
begin
 if Assigned(Form) then
  begin
   //save current domain
   if Domain='' then
     CurrDomain:=''
   else
     CurrDomain:=getcurrenttextdomain;
   //save current language
   CurrLang:=GetCurrentLanguage;
   //change to specified domain
   if Domain<>'' then
    begin
     if Domain<>CurrDomain then
       textdomain(Domain);
    end;
   //change to specified language
   if Language<>CurrLang then
     UseLang(Language);
   //translate what we need
   RetranslateComponent(Form);
   if Assigned(TranslateToo) then
      TranslateToo;
   //restore domain
   if RestoreDomain then
    begin
     if CurrDomain<>'' then
      begin
       if CurrDomain<>Domain then
         textdomain(CurrDomain);
      end;
    end;
   //restore language
   if RestoreLanguage then
    begin
     if CurrLang<>Language then
       UseLanguage(CurrLang);
    end;
  end;
end;

initialization

finalization

 LocalesListFree;
 
end.
